#  jlibauth.tcl --
#  
#      This file is part of the jabberlib. It provides support for the
#      Non-auth authentication layer (XEP-0078).
#      
#  Copyright (c) 2005 Sergei Golovan <sgolovan@nes.ru>
#  
# $Id: jlibauth.tcl 1244 2007-10-06 07:53:04Z sergei $
#
# SYNOPSIS
#   jlibauth::new connid args
#	creates auth token
#	args: -sessionid   sessionid
#	      -username    username
#	      -server      server
#	      -resource    resource
#	      -password    password
#	      -allow_plain boolean
#	      -command     callback
#
#   token configure args
#	configures token parameters
#	args: the same as in jlibauth::new
#
#   token auth args
#	starts authenticating procedure
#	args: the same as in jlibauth::new
#
#   token free
#	frees token resourses

##########################################################################

package require sha1
package require namespaces 1.0

package provide jlibauth 1.0

##########################################################################

namespace eval jlibauth {
    variable uid 0
}

##########################################################################

proc jlibauth::new {connid args} {
    variable uid

    set token [namespace current]::[incr uid]
    variable $token
    upvar 0 $token state

    ::LOG "(jlibauth::new $connid) $token"

    set state(-connid) $connid
    set state(-allow_plain) 0

    proc $token {cmd args} \
	"eval {[namespace current]::\$cmd} {$token} \$args"

    eval [list configure $token] $args

    jlib::register_xmlns $state(-connid) $::NS(iq-auth) \
	[list [namespace code parse] $token]

    jlib::register_xmlns $state(-connid) $::NS(iq-register) \
	[list [namespace code parse] $token]

    
    return $token
}

##########################################################################

proc jlibauth::free {token} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibauth::free $token)"

    jlib::unregister_xmlns $state(-connid) $::NS(iq-auth)
    jlib::unregister_xmlns $state(-connid) $::NS(iq-register)

    catch { unset state }
    catch { rename $token "" }
}

##########################################################################

proc jlibauth::configure {token args} {
    variable $token
    upvar 0 $token state

    foreach {key val} $args {
	switch -- $key {
	    -sessionid -
	    -username -
	    -server -
	    -resource -
	    -password -
	    -allow_plain -
	    -command {
		set state($key) $val
	    }
	    default {
		return -code error "Illegal option \"$key\""
	    }
	}
    }
}

##########################################################################

proc jlibauth::parse {token xmldata} {
    variable $token
    upvar 0 $token state

    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children

    switch -- $tag {
	auth {
	    set state(nonsasl) 1
	}
	register {
	    set state(isregister) 1
	}
    }
}

##########################################################################

proc jlibauth::auth {token args} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibauth::auth $token) start"

    eval [list configure $token] $args

    foreach key [list -sessionid \
		      -username \
		      -resource \
		      -password] {
	if {![info exists state($key)]} {
	    return -code error "Auth error: missing option \"$key\""
	}
    }

    jlib::trace_stream_features \
	$state(-connid) \
	[list [namespace code auth_continue] $token]
}

proc jlibauth::areg {token args} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibauth::areg $token) start"

    eval [list configure $token] $args

    foreach key [list -sessionid \
		      -username \
		      -password] {
	if {![info exists state($key)]} {
	    return -code error "Reg error: missing option \"$key\""
	}
    }

    jlib::trace_stream_features \
	$state(-connid) \
	[list [namespace code areg_continue] $token]
}

##########################################################################

proc jlibauth::auth_continue {token} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibauth::auth_continue $token)"
    
    if {![info exists state(nonsasl)]} {
	finish $token ERR \
	    [concat modify \
		 [stanzaerror::error modify not-acceptable -text \
		      [::msgcat::mc \
			   "Server haven't provided non-SASL\
			    authentication feature"]]]
	return
    }
    
    set data [jlib::wrapper:createtag query \
		  -vars    [list xmlns $::NS(auth)] \
		  -subtags [list [jlib::wrapper:createtag username \
				     -chdata $state(-username)]]]

    jlib::send_iq get $data \
	-command [list [namespace code auth_continue2] $token] \
	-connection $state(-connid)
}

proc jlibauth::areg_continue {token} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibauth::areg_continue $token)"
    
    if {![info exists state(isregister)]} {
	finish $token ERR \
	    [concat modify \
		 [stanzaerror::error modify not-acceptable -text \
		      [::msgcat::mc \
			   "Server haven't provided registration"]]]
	return
    }
    
    if {[info exists state(-command)]} {
	# Should we report about disconnect too?
	uplevel #0 $state(-command) [list OK {}]
    }
}

##########################################################################

proc jlibauth::auth_continue2 {token res xmldata} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibauth::auth_continue2 $token) $res"

    if {$res != "OK"} {
	finish $token $res $xmldata
	return
    }

    jlib::wrapper:splitxml $xmldata tag vars isempty chdata children

    set authtype ""
    foreach child $children {

	jlib::wrapper:splitxml $child tag1 vars1 isempty1 chdata1 children1

	switch -- $tag1 {
	    password {
		if {$authtype == ""} {
		    if {$state(-allow_plain)} {
			set authtype plain
		    } else {
			set authtype forbidden
		    }
		}
	    }
	    digest {
		set authtype digest
	    }
	}
    }

    switch -- $authtype {
	plain {
	    set data [jlib::wrapper:createtag query \
			  -vars    [list xmlns $::NS(auth)] \
			  -subtags [list [jlib::wrapper:createtag username \
					      -chdata $state(-username)] \
					 [jlib::wrapper:createtag password \
					      -chdata $state(-password)] \
					 [jlib::wrapper:createtag resource \
					      -chdata $state(-resource)]]]
	}
	digest {
	    set secret [encoding convertto utf-8 $state(-sessionid)]
	    append secret [encoding convertto utf-8 $state(-password)]
	    set digest [sha1::sha1 $secret]
	    set data [jlib::wrapper:createtag query \
			  -vars    [list xmlns $::NS(auth)] \
			  -subtags [list [jlib::wrapper:createtag username \
					      -chdata $state(-username)] \
					 [jlib::wrapper:createtag digest \
					      -chdata $digest] \
					 [jlib::wrapper:createtag resource \
					      -chdata $state(-resource)]]]
	}
	forbidden {
	    finish $token ERR \
		[concat modify \
		     [stanzaerror::error modify not-acceptable -text \
			  [::msgcat::mc \
			       "Server doesn't support hashed password\
			        authentication"]]]
	    return
	}
	default {
	    finish $token ERR \
		[concat modify \
		     [stanzaerror::error modify not-acceptable -text \
			  [::msgcat::mc \
			       "Server doesn't support plain or digest\
			        authentication"]]]
	    return
	}
    }

    jlib::client status [::msgcat::mc "Waiting for authentication results"]
    jlib::send_iq set $data \
	-command [list [namespace code finish] $token] \
	-connection $state(-connid)
}

##########################################################################

proc jlibauth::finish {token res xmldata} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibauth::finish $token) $res"

    if {$res != "OK"} {
	jlib::client status [::msgcat::mc "Authentication failed"]
    } else {
	jlib::client status [::msgcat::mc "Authentication successful"]
    }
    if {$res != "DISCONNECT" && [info exists state(-command)]} {
	# Should we report about disconnect too?
	uplevel #0 $state(-command) [list $res $xmldata]
    }
}

##########################################################################

